home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / surfsrc3.zip / IFF.INC < prev    next >
Text File  |  1991-09-25  |  10KB  |  381 lines
  1. { IFF.INC - IFF (Amiga Interchange File Format) support for SURFMODL }
  2.  
  3. { Local constants, types and variables for IFF saving: }
  4. const
  5.     Bmapsize: word = 0;
  6.     Nplanes: integer = 5;
  7.  
  8. type
  9.     Bytearray = array[0..0] of byte;
  10.     Byteptr = ^Bytearray;
  11.     formchunk = record
  12.       fc_type: array[0..3] of byte;
  13.       fc_length: longint;
  14.       fc_subtype: array[0..3] of byte;
  15.     end;
  16.     iffchunk = record
  17.       iff_type: array[0..3] of byte;
  18.       iff_length: longint;
  19.     end;
  20.     bitmapheader = record
  21.       w: word;
  22.       h: word;
  23.       x: word;
  24.       y: word;
  25.       nplanes: byte;
  26.       masking: byte;
  27.       compression: byte;
  28.       pad1: byte;
  29.       transparentcolor: word;
  30.       xaspect: byte;
  31.       yaspect: byte;
  32.       pagewidth: integer;
  33.       pageheight: integer;
  34.     end;
  35.  
  36. { Global variables }
  37. var IFFbmap: Byteptr;       { pointer to screen bitmap }
  38.     Shiftvals: array[0..7] of byte;   { values to do bit shifts }
  39.     IFFxmax: word;          { max screen coord }
  40.     IFFymax: word;          { max screen coord }
  41.     IFFcolors: integer;     { # screen colors }
  42.  
  43. { MEMSET: Set every byte in specified memory to a specified value. }
  44. procedure MEMSET (dat: pointer; val, len: word);
  45. var i: word;
  46.     p: Byteptr;
  47.  
  48. begin
  49.   p := dat;
  50.   for i := 0 to len-1 do
  51.     p^[i] := val;
  52. end; { procedure MEMSET }
  53.  
  54. procedure INITIFF;
  55. var i: integer;
  56.     Shiftval: integer;
  57.  
  58. begin
  59.   { Free up the old bitmap, if there is one }
  60.   if (Bmapsize > 0) then
  61.     freemem (IFFbmap, Bmapsize);
  62.  
  63.   { Allocate the bitmap.  Note we use one byte per pixel, so the color
  64.     resolution is the same as VGA (8-bit).
  65.   }
  66.   IFFxmax := getmaxx;
  67.   IFFymax := getmaxy;
  68.   IFFcolors := getmaxcolor;
  69.   Bmapsize := (IFFxmax+1) * (IFFymax+1);
  70.   getmem (IFFbmap, Bmapsize);
  71.   if (IFFbmap = NIL) then begin
  72.     writeln('Out of memory allocating bitmap');
  73.     Bmapsize := 0;
  74.     halt;
  75.   end;
  76.   { Initialize to zero }
  77.   memset (IFFbmap, 0, Bmapsize);
  78.  
  79.   { Finally we initialize the shift values.  This is necessary because
  80.     Pascal doesn't have a shift operator (that I know of).  But hey what
  81.     do I know, I'm just a C programmer at heart.
  82.   }
  83.   Shiftval := 1;
  84.   for i := 0 to 7 do begin
  85.     Shiftvals[i] := Shiftval;
  86.     Shiftval := Shiftval * 2;
  87.   end;
  88. end; { procedure INITIFF }
  89.  
  90. procedure EXITIFF;
  91. begin
  92.   { Free up the old bitmap, if there is one }
  93.   if (Bmapsize > 0) then
  94.     freemem (IFFbmap, Bmapsize);
  95.   Bmapsize := 0;
  96. end; { procedure EXITIFF }
  97.  
  98. procedure IFFPLOT (X, Y, Color: integer);
  99. var Offs: word;             { Offset into bitmap }
  100. {$ifdef NEVER}
  101.     Value: integer;
  102. {$endif}
  103.  
  104. begin
  105.   if (X < 0) or (X > IFFxmax) or (Y < 0) or (Y > IFFymax) or
  106.       (Color < 0) or (Color > 255) then begin
  107.     writeln('IFFPLOT: Illegal parameters X=', X, ' Y=', Y, ' Color=', Color);
  108.     halt;
  109.   end;
  110.  
  111.   { Find the offset into the bitmap for this pixel }
  112.   Offs := Y * (IFFxmax+1) + X;
  113.   IFFbmap^[Offs] := Color;
  114. {$ifdef NEVER}
  115.   writeln('X=', X, ' Y=', Y, ' Color=', Color);
  116.   Value := ord (IFFbmap^[Offs]);
  117.   write('  IFFbmap[', Offs, ']: Val=', Value);
  118.   showptr(@IFFbmap^[Offs]);
  119. {$endif}
  120. end; { procedure IFFPLOT }
  121.  
  122. procedure SWAP_BYTES (dat: pointer; len: word);
  123. var tmp: byte;
  124.     i1, i2: word;
  125.     p: Byteptr;
  126.  
  127. begin
  128.   p := dat;
  129.   i1 := 0;
  130.   i2 := len - 1;
  131.   while (i1 < i2) do begin
  132.     tmp := p^[i2];
  133.     p^[i2] := p^[i1];
  134.     p^[i1] := tmp;
  135.     i1 := i1 + 1;
  136.     i2 := i2 - 1;
  137.   end;
  138. end; { procedure SWAP_BYTES }
  139.  
  140. { GET1ROW: Transform one bitplane of one row of pixels from our internal
  141.   (VGA-type) format into IFF format.
  142. }
  143. procedure GET1ROW (y, plane: integer; var row: RowArray; var nbytes: integer);
  144. var Offs: word;     { offset into bitmap }
  145.     bit: integer;   { current bit# in byte }
  146.     Col: byte;      { color of current pixel }
  147.     Value: byte;    { color value for this bitplane }
  148.     n: integer;     { current byte number in this line }
  149.  
  150. begin
  151.   if (Plane < 0) or (Plane >= Nplanes) or (y < 0) or (y > IFFymax) then begin
  152.     writeln ('GET1ROW - Invalid input Plane=', plane, ' y=', y);
  153.     halt;
  154.   end;
  155.  
  156.   { Calculate offset into bitplane }
  157.   Offs := y * (IFFxmax + 1);
  158.   nbytes := (IFFxmax + 1) div 8;
  159.   { Do for each group of 8 pixels across the screen.  Note we handle 8
  160.     pixels at a time to save calculation, since that is how we need it
  161.     represented for IFF.
  162.   }
  163.   for n := 0 to nbytes-1 do begin
  164.     row[n] := 0;
  165.     { Do for each pixel in the group of 8.  Note that we need to read
  166.       each bit in reverse order.
  167.     }
  168.     for Bit := 7 downto 0 do begin
  169.       Col := ord (IFFbmap^[Offs]);
  170.       Offs := Offs + 1;
  171.       if (Col >= IFFcolors) then begin
  172.         writeln ('ERROR in GET1ROW: Col=', Col);
  173.         halt;
  174.       end;
  175.  
  176.       { Mask off the bitplane that was requested, and shift it down to bit 0: }
  177.       Value := (Col and Shiftvals[Plane]) div Shiftvals[Plane];
  178.  
  179.       {Finally, shift the value into the appropriate bit pos for IFF: }
  180.       row[n] := row[n] or (Value * Shiftvals[Bit]);
  181.     end; { for i }
  182.   end; { for n }
  183.  
  184. end; { procedure GET1ROW }
  185.     
  186. procedure WRITE_BODY (var out: file; var tot_len: longint);
  187. var y: integer;
  188.     plane: integer;
  189.     nbytes: integer;
  190.     row: RowArray;
  191.  
  192. begin
  193.  
  194.   { For each row }
  195.   for y := 0 to IFFymax do begin
  196.     { For each bitplane }
  197.     for plane := 0 to Nplanes-1 do begin
  198.       get1row (y, plane, row, nbytes);
  199.       blockwrite (out, row, nbytes);
  200.       tot_len := tot_len + nbytes;
  201.     end;
  202.   end;
  203. end; { procedure WRITE_BODY }
  204.  
  205. procedure SAVEIFF (Filename: string; var Pal: SurfPalette);
  206.  
  207. var tmp: longint;
  208.     out: file;
  209.     form: formchunk;
  210.     iff: iffchunk;
  211.     hdr: bitmapheader;
  212.     r, g, b: integer;
  213. {$ifdef NEVER}
  214.     curr: integer;
  215.     ch: char;
  216. {$endif}
  217.     tot_len: longint;
  218.     name: string[4];
  219.  
  220. begin
  221.  
  222. {$ifdef NEVER}
  223.   window(1,1,80,25);
  224.   clrscr;
  225. {$endif}
  226.   if (Bmapsize = 0) then begin
  227.     writeln ('SAVEIFF ERROR: Never initialized!');
  228.     halt;
  229.   end;
  230.  
  231. {$I-}
  232.   assign (out, Filename);
  233.   rewrite (out, 1);
  234. {$I+}
  235.   if (ioresult <> 0) then begin
  236.     writeln ('Error: Can''t create ', Filename);
  237.     halt;
  238.   end;
  239.  
  240.   { FORM: ILBM (Interleaved BitMap) }
  241.   name := 'FORM';
  242.   move (name[1], form.fc_type, 4);
  243.   tmp := ((IFFxmax+1) div 8) * Nplanes;
  244.   form.fc_length := 12 + 28 + 8 + (3*IFFcolors) + 8 + tmp * (IFFymax+1);
  245.   { KVC 09/25/91 For some reason IFFCHECK expects this number to be 8
  246.     smaller than I calculate.  Don't know why, but here's a correction
  247.     to force it:
  248.   }
  249.   form.fc_length := form.fc_length - 8;
  250. {$ifdef NEVER}
  251.   writeln('Expected file size: ', form.fc_length);
  252. {$endif}
  253.   name := 'ILBM';
  254.   move (name[1], form.fc_subtype, 4);
  255.   swap_bytes (@form.fc_length, sizeof(longint));
  256.   blockwrite (out, form, sizeof(form));
  257.   tot_len := sizeof(form);
  258. {$ifdef NEVER}
  259.   writeln('After ILBM: ', tot_len);
  260. {$endif}
  261.  
  262.   { BMHD (Bitmap Header) }
  263.   name := 'BMHD';
  264.   move (name[1], iff.iff_type, 4);
  265.   iff.iff_length := sizeof(hdr);
  266.   swap_bytes (@iff.iff_length, 4);
  267.   blockwrite (out, iff, sizeof(iff));
  268.   tot_len := tot_len + sizeof(iff);
  269. {$ifdef NEVER}
  270.   writeln('After BMHD: ', tot_len, ' (should be 20)');
  271. {$endif}
  272.  
  273.   hdr.w := IFFxmax + 1;
  274.   hdr.h := IFFymax + 1;
  275.   hdr.x := 0;
  276.   hdr.y := 0;
  277.   hdr.nplanes := Nplanes;
  278.   hdr.masking := 0;
  279.   hdr.compression := 0;
  280.   hdr.pad1 := 0;
  281.   hdr.transparentcolor := 0;
  282.   hdr.xaspect := 10;
  283.   hdr.yaspect := 11;
  284.   hdr.pagewidth := IFFxmax + 1;
  285.   hdr.pageheight := IFFymax + 1;
  286.   hdr.w := swap (hdr.w);
  287.   hdr.h := swap (hdr.h);
  288.   hdr.x := swap (hdr.x);
  289.   hdr.y := swap (hdr.y);
  290.   hdr.transparentcolor := swap (hdr.transparentcolor);
  291.   hdr.pagewidth := swap (hdr.pagewidth);
  292.   hdr.pageheight := swap (hdr.pageheight);
  293.   blockwrite (out, hdr, sizeof(hdr));
  294.   tot_len := tot_len + sizeof(hdr);
  295. {$ifdef NEVER}
  296.   writeln('After hdr: ', tot_len, ' (should be 40)');
  297. {$endif}
  298.  
  299.   { Color Map }
  300.   name := 'CMAP';
  301.   move (name[1], iff.iff_type, 4);
  302.   iff.iff_length := 3 * IFFcolors;
  303.   swap_bytes (@iff.iff_length, 4);
  304.   blockwrite (out, iff, sizeof(iff));
  305.   tot_len := tot_len + sizeof(iff);
  306. {$ifdef NEVER}
  307.   writeln('After CMAP: ', tot_len, ' (should be 48)');
  308. {$endif}
  309.  
  310. {$ifdef NEVER}
  311.   { Set up a greyscale color map }
  312.   for curr := 0 to 15 do begin
  313.     Pal[curr].Rvalue := curr * 16;
  314.     Pal[curr].Gvalue := curr * 16;
  315.     Pal[curr].Bvalue := curr * 16;
  316.     writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
  317.         Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
  318.   end;
  319.   if (IFFcolors > 16) then begin
  320.     { Set the rest of the colors to white }
  321.     for curr := 16 to MAXCOLORS do begin
  322.       Pal[curr].Rvalue := 15;
  323.       Pal[curr].Gvalue := 15;
  324.       Pal[curr].Bvalue := 15;
  325.     end;
  326.   end;
  327. {$endif}
  328.  
  329. {$ifdef NEVER}
  330.   for curr := 1 to 16 do
  331.     writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
  332.         Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
  333.   write('Press any key to continue...');
  334.   ch := readkey;
  335.   writeln;
  336.   for curr := 17 to IFFcolors do
  337.     writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
  338.         Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
  339.   write('Press any key to continue...');
  340.   ch := readkey;
  341.   writeln;
  342. {$endif}
  343.  
  344.   blockwrite (out, Pal, IFFcolors * sizeof(ColorValue));
  345.   tot_len := tot_len + IFFcolors * sizeof(ColorValue);
  346.  
  347. {$ifdef NEVER}
  348.   writeln('After cmap: ', tot_len, ' (sz=', IFFcolors * sizeof(ColorValue),
  349.       ') (tot should be 144)');
  350. {$endif}
  351.  
  352.   { Finally save the body of the picture: }
  353.   name := 'BODY';
  354.   move (name[1], iff.iff_type, 4);
  355.   iff.iff_length := (IFFxmax + 1) div 8 * (IFFymax + 1) * Nplanes;
  356.   swap_bytes (@iff.iff_length, 4);
  357.   blockwrite (out, iff, sizeof(iff));
  358.   tot_len := tot_len + sizeof(iff);
  359. {$ifdef NEVER}
  360.   writeln('After BODY: ', tot_len, ' (should be 152)');
  361. {$endif}
  362.  
  363.   write_body (out, tot_len);
  364. {$ifdef NEVER}
  365.   writeln('After body: ', tot_len, ' (should be 40152)');
  366. {$endif}
  367.  
  368.   { If we start using compression, we will have to seek back to the point
  369.     where the body length was written, and update it.  We will also have
  370.     to seek back to where the initial ILBM header was written, and update
  371.     its length too.
  372.   }
  373.  
  374.   close (out);
  375.  
  376. {$ifdef NEVER}
  377.   writeln('Actual file size: ', tot_len);
  378. {$endif}
  379.  
  380. end; { procedure SAVEIFF }
  381.